home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / debug / queries.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  10.2 KB  |  292 lines
  1. (* DebugQueries
  2.  
  3.    User-level queries.
  4.    By convention, these are all relative to an explicitly given time.
  5.    They should only be called when imbedded in some DebugMotion routine
  6.    (e.g., withEstablishedTime or binSearch) that ensures interrupt handler
  7.    is set, established time is reset, etc.
  8.    On interrupt, these routines return something dumb, and expect an outer
  9.    wrapper to do something sensible when they notice the flag is still set.
  10. *)
  11.  
  12.  
  13. signature DEBUG_QUERIES =
  14. sig
  15.   type time
  16.   type place 
  17.   type wherewhen (* = place * time *)
  18.   val caller: time -> (wherewhen*wherewhen) 
  19.       (* Return top of function,caller for given time. *)
  20.   val callTrace: int -> time -> 
  21.                  ((wherewhen*wherewhen*(((string*Types.ty)*System.Unsafe.object) list)) list)
  22.       (* Return specified number of call frames from given time.
  23.          Each frame gives top of function, caller, and list of 
  24.        ((name*type)*value) for each function argument bound at the call. *)
  25.   val eventDesc : place -> (string * bool * DebugStatic.location * DebugStatic.visible) option
  26.       (* Return descriptive string, pseudo-ness, location, 
  27.          and visibility attributes for given place. *)
  28.   val lastTimes : place -> time * time
  29.       (* Return (min,max) of last times for evns including place. *)
  30.   val atCall : time -> bool
  31.       (* Return true iff time refers to a call point (APP, etc.) *)
  32.   val getVal: string -> time -> 
  33.                   (System.Unsafe.object * Types.ty * wherewhen) option
  34.       (* Return value*type*binding site for given val identifier looking
  35.          backwards from given time. *)
  36.   val printBind: (wherewhen * int) -> unit
  37.       (* Print binding information for binding at given wherewhen. *)
  38.   val printVal: (System.Unsafe.object * Types.ty) -> unit
  39.   val exnArg: exn -> (System.Unsafe.object * Types.ty) option
  40. end
  41.  
  42. structure DebugQueries : DEBUG_QUERIES =
  43. struct
  44.   (* These functions should be imbedded (directly or at some deeper level)
  45.      within some X motion routine, to ensure the interrupt handler is set.
  46.      Policy on interrupts: returns something foolish and relies on caller
  47.      to re-detect pendingInterrupt. *)
  48.  
  49.   open DebugUtil DebugRun DebugBindings DebugStatic DebugExec Modules
  50.        Access Absyn Types PrintUtil Variables
  51.   structure U = System.Unsafe
  52.  
  53.   type wherewhen = place * time
  54.  
  55.   val say = System.Print.say
  56.  
  57.   val pdepth = 100
  58.  
  59.   (* Suitable for support functions that do time-travel and may be 
  60.      called from within time-sensitive contexts. Callers must
  61.      check of pendingInterrupt on their return. *)
  62.   fun keepOriginalTime f =
  63.     let val originalTime = currentTime()
  64.     in f() before
  65.        (if not (!pendingInterrupt) then
  66.        resetTo (originalTime,true,QUIET)
  67.         else ()) (* caller will need to deal with interrupt anyhow *)
  68.     end
  69.  
  70.   val eventsAt = eventsFor o evnAt
  71.  
  72.   fun currentWhereWhen () = (hd(placesFor(currentEvn())),currentTime())
  73.     
  74.   fun caller (time:time) : (wherewhen*wherewhen) =
  75.       (* return top of function containing time, caller of this function *)
  76.     keepOriginalTime (fn () =>
  77.     let fun lastfunc(0,(evn,_)) = (0,evn,0)
  78.           | lastfunc(t,(evn,lbt)) =
  79.            let fun f (FNev(_)::_,n) = (t,evn,n)
  80.              | f (HANDLEev(_)::_,n) = (t,evn,n)
  81.              | f (evt::rest,n) = f(rest,n+1)
  82.              | f (nil,_) = lastfunc(lbt,evnLbtAt lbt)
  83.            in if !pendingInterrupt then
  84.                 raise QueryInterrupted
  85.               else f (eventsFor evn,0)
  86.            end
  87.         val (t,evn,n) = lastfunc(time,evnLbtAt time)
  88.         val (t',evn') = if t > 0 then
  89.                       let val pt = pred t
  90.                   in (pt,evnAt pt)
  91.                   end
  92.                 else (0,0)
  93.     in ((nth(placesFor evn,n),t),(hd(placesFor evn'),t'))
  94.     end handle QueryInterrupted => ((0,0),(0,0)))
  95.  
  96.   fun eventDesc (place:place) :
  97.          (string * bool * location * visible) option =
  98.     let val evt = eventForPlace place
  99.     val (filename,visible) = filenameFor place
  100.     val charno = locOfEvent evt
  101.     in SOME (eventText evt,isPseudo evt,(filename,charno),visible)
  102.     end handle Nth => NONE
  103.  
  104.   fun lastTimes (place:place) : time * time =
  105.       (* return (min,max) of last times for evn's containing place. *)
  106.       let fun check(evn,(mint,maxt)) =
  107.       let val t = lastTime evn
  108.       in (min(mint,t),max(maxt,t))
  109.       end
  110.       in fold check (evnsFor place) (infinity,~infinity)
  111.       end
  112.  
  113.   fun atCall (t:time) =
  114.     case hd (eventsAt t) of
  115.       (APPev _) => true
  116.     | (RAISEev _) => true
  117.     | _ => false
  118.  
  119.   (* Routine getVal supports looking up VARCON's using full path names;
  120.      returns with unbundled value, type and binding site information option.
  121.    Intended use: supporting pointing at source. 
  122.    Sample packaging:  
  123.     getVal' (n:string) = withEstablishedTime(getVal n)
  124.    with the INTERRUPT x return assumed corrupt. *)
  125.  
  126.   local
  127.      fun split s =
  128.      let fun sp s =
  129.          let val pos = index (fn c => c = ".") (explode s)
  130.          in substring (s,0,pos) :: 
  131.          sp (substring(s,pos+1, String.length s - (pos+1)))
  132.          end handle Index => [s]
  133.      in rev (sp s)
  134.      end
  135.   in
  136.   fun getVal (n:string) (time:time) : 
  137.                      (U.object * ty * wherewhen) option  =
  138.       keepOriginalTime (fn () =>
  139.       let val (t,c,(i,binding)) = findVARCONBind (split n, time,0) 
  140.       in case binding of
  141.        VARbind(v as VALvar{typ=ref ty,...}) =>
  142.          let val (evn,args) = evnArgsAt t
  143.               val bv = nth (nthArgs(evn,c,args),i)
  144.              val ty = dynTypeAt (t,c) ty
  145.              val ww = (nth(placesFor evn,c),t)
  146.              in SOME(bv,ty,ww)
  147.              end 
  148.      | VARbind (OVLDvar _) => NONE
  149.      | CONbind(dc as (DATACON{const,rep,sign,typ,...}))  =>
  150.          let val (evn,args) = evnArgsAt t
  151.          val ty = dynTypeAt (t,c) typ
  152.          val bv = case rep of
  153.                      VARIABLE _ =>  nth(nthArgs(evn,c,args),i)
  154.                | VARIABLEc _ => nth(nthArgs(evn,c,args),i)
  155.                      | _ => U.cast 0 
  156.                              (* no run-time object exists *)
  157.          val ww = (nth(placesFor evn,c),t)
  158.          in SOME(bv,ty,ww)
  159.          end 
  160.       end handle Env.Unbound => NONE | QueryInterrupted => NONE)
  161.   end  (* local *)
  162.  
  163.  
  164.  
  165.  
  166.   local
  167.     fun nametype (t,c) = 
  168.               fn (v as VALvar{name=[nm],typ=ref ty,...}) =>
  169.             (Symbol.name nm, 
  170.              fn () => dynTypeAt (t,c) ty)
  171.           | _ => debugPanic "bad var in queries.nametype"
  172.  
  173.   in
  174.   fun callTrace (maxdepth:int) (time:time):
  175.       ((wherewhen*wherewhen*(((string*ty)*U.object) list)) list) = 
  176.     keepOriginalTime (fn () => 
  177.     let fun dotype (name,typef) = (name,typef())
  178.         fun lastfunc(0,(evn,_,_)) = (0,evn,0,nil)
  179.           | lastfunc(t,(evn,lbt,args)) =
  180.            let fun f (FNev (RULE(pat,_))::_,n,args) = 
  181.                   (t,evn,n,pairlist (patvars (dotype o (nametype (t,n))) pat) args)
  182.              | f (HANDLEev (RULE(pat,_))::_,n,args) =
  183.                   (t,evn,n,pairlist (patvars (dotype o (nametype (t,n))) pat) args)
  184.              | f (evt::rest,n,args) = f(rest,n+1,tln (args,argCnt evt))
  185.   
  186.              | f (nil,_,_) = lastfunc(lbt,evnLbtArgsAt lbt)
  187.            in f (eventsFor evn,0,args)
  188.            end
  189.         fun up 0 _ = nil
  190.           | up _ 0 = nil
  191.           | up t d =
  192.            let val evdata as (evn,_,_) = evnLbtArgsAt (pred t)
  193.                val (t',evn',n,varlist) = lastfunc(pred t,evdata)
  194.            in
  195.              ((hd(placesFor evn),pred t),
  196.               (nth(placesFor evn',n),t'),
  197.               varlist) :: 
  198.              (up t' (d-1))
  199.            end
  200.         val cww = currentWhereWhen()
  201.         val (t',evn',n,varlist) = lastfunc (time,evnLbtArgsAt time)
  202.     in (cww,(nth(placesFor evn',n),t'),varlist) :: (up t' maxdepth) 
  203.           handle QueryInterrupted => nil  
  204.                (* could do better if we really wanted to *)
  205.     end)
  206.   end (* local *)
  207.  
  208.   fun printBind ((place:place,t:time),indent:int) : unit =
  209.    keepOriginalTime (fn () => 
  210.     let val env = StaticEnv.atop(#static(DebugEnv.debugEnvironment),
  211.                    !debugStatEnv)
  212.     open PrettyPrint
  213.     val consumer = ErrorMsg.defaultConsumer()
  214.     fun printDec arg =
  215.         with_pp consumer (fn ppstrm => PPAbsyn.ppDec (env,NONE) ppstrm arg)
  216.     in         
  217.      case eventForPlace place of
  218.        VALev(MARKdec(dec as VALdec(_),_,_)) => printDec (dec,pdepth)
  219.      | VALRECev(MARKdec(dec as VALRECdec(_),_,_)) => 
  220.        printDec (dec,pdepth)
  221.      | FNev(RULE(pat,_)) => 
  222.          with_pp consumer (fn ppstrm => 
  223.       (PPAbsyn.ppPat env ppstrm (pat,pdepth);
  224.        add_string ppstrm " <=== ";
  225.        case hd(eventsAt (pred t))
  226.          of APPev(APPexp(_,exp)) =>
  227.           PPAbsyn.ppExp (env,NONE) ppstrm (exp,pdepth)
  228.           | _ => add_string ppstrm  "unknown call site"))
  229.      | HANDLEev(RULE(pat,_)) =>
  230.          with_pp consumer (fn ppstrm => 
  231.       (PPAbsyn.ppPat env ppstrm (pat,pdepth);
  232.        add_string ppstrm " <=== ";
  233.        case hd(eventsAt (pred t))
  234.          of RAISEev(MARKexp(RAISEexp(exp,_),_,_)) => 
  235.           PPAbsyn.ppExp (env,NONE) ppstrm (exp,pdepth)
  236.           | _ => add_string ppstrm "implicit exception"))
  237.      | CASEev(exp,RULE(pat,_)) => 
  238.          with_pp consumer (fn ppstrm => 
  239.       (PPAbsyn.ppPat env ppstrm (pat,pdepth);
  240.        add_string ppstrm " <=== ";
  241.        PPAbsyn.ppExp (env,NONE) ppstrm (exp,pdepth)))
  242.      | _ => debugPanic "bad event type in queries.printBind"
  243.     end handle QueryInterrupted => ())
  244.  
  245.    fun printVal(v,t) = 
  246.       let val env = StaticEnv.atop(#static(DebugEnv.debugEnvironment),
  247.                  !debugStatEnv)
  248.       in  PrettyPrint.with_pp (ErrorMsg.defaultConsumer())
  249.         (fn ppstrm => 
  250.           PPVal.ppVal env ppstrm (v,t,!System.Print.printDepth))
  251.       end
  252.  
  253.    (* Return argument and type associated with an exception, if any; else NONE.
  254.     Also return NONE if exception declaration was not instrumented for
  255.     debugging. *)
  256.    local
  257.      open System.Tags
  258.      val string_tag = make_desc(0,tag_string)
  259.      and embedded_string_tag = make_desc(0,tag_embedded_string)
  260.    in
  261.    fun exnArg (exn:exn) : (U.object * ty) option =
  262.      let val (ref s,v) = U.cast exn
  263.      in if not(U.boxed s) orelse 
  264.        let val tag = U.getObjTag s 
  265.        in tag = string_tag orelse tag = embedded_string_tag 
  266.        end 
  267.     then
  268.       NONE (* non-debugger exception *)
  269.     else
  270.       let val (name0:string,t:time) = U.cast s
  271.           fun find ((EBgen{exn=DATACON{name,...},etype,...})::rest) =
  272.                  if name0 = Symbol.name name then
  273.                case etype of
  274.                  SOME ty => SOME(v,dynTypeAt (t,0) ty)
  275.                | NONE => NONE
  276.              else find rest
  277.         | find (_::rest) = find rest
  278.         | find nil = debugPanic "no matching name in queries.exnArg"
  279.       in keepOriginalTime
  280.           (fn () => 
  281.             (case hd(eventsAt t) of
  282.            EXCEPTIONev(MARKdec(EXCEPTIONdec ebl,_,_)) => find ebl
  283.              | _ => debugPanic "bad event type in queries.exnArg")
  284.              handle QueryInterrupted => NONE)
  285.       end
  286.      end
  287.    end
  288. end
  289.  
  290.  
  291.  
  292.